perm filename WORDS.F4[MSS,LCS]1 blob
sn#131222 filedate 1974-11-15 generic text, type T, neo UTF8
00100 C SUBRS WORDS, TYPE, SETLET, SETNUM
00200
00300 SUBROUTINE WORDS
00400 COMMON RJB,JA,RC,JC,RJC,RJD,RJE,RJF,RJG,X,IA,N
00500 1,Z,J,KN,ISET,Q(28) /PTR/PWDS(250),ITEM,LL,IS,IX
00600 COMMON/SCX/RHY(4),JALPHA(19),JD,L,Y,K,RX,RZ,RA,JE
00700 1/XRN/RN(4000) /ALF/INP(72),ML
00800 DATA KSLA/'/'/,IBLA/' '/
00900 1,JALPHA/',','-','.','=','(',')','+',
01000 1 '*',':',';','"',' ','$','%','&','@','#','<','>'/
01100 C FOR ENTERING TEXT: 16, POS., STF., NT#., SIZE, RHYTHM≠0
01200 C RJF ≠0 CALLS NOTE NUM. SETUP
01300 CALL TYPE
01400 DO 31 KN=72,1,-1
01500 31 IF(INP(KN).NE.IBLA)GO TO 33
01600 C KN=NUM OF CHARACTERS
01700 C DON'T END WITH '*' IN 'LETTERS' INPUT!!!!!!!!
01800 C , - . = ( ) + * : ; " BLANK --THIS IS ORDER PAST ALPHAB.
01900 C $=UPPER CASE, %=LOWER, &=NON-ITALICS, @=ITALICS (48,49,50,51)
02000 C #=RETURN TO PRIMITVE FONT
02100 33 L=1
02200 LL=1
02300 RA=RJB
02400 C RA= ADDS UP TOTAL SPACE NEEDED
02500 RX=0
02600 RZ=0
02700 ISET=IS
02800 C FOR SETLET
02900 368 RN(IS+1)=16
03000 RN(IS+2)=RA
03100 C NEXT IS A MAGIC NUMBER FOR SPACING LETTERS.
03200 Y=39.6*RSTJC
03300 C RBL IS FOR CONTROL(NON-LETTERS, ETC.) CHARACTERS.
03400 RN(IS+3)=RJC
03500 RN(IS+4)=RJD
03600 CALL NOZERO(RJE)
03700 RN(IS+5)=RJE
03800
03900 DO 364 JE=6,8
04000 Z=0
04100 DO 363 JD=1,4
04200 361 IA=INP(L)
04300 IF(IA.NE.KSLA)GO TO 365
04400 C NEG. SPACE IS ENTERED IN P1 FOR EACH "FIRST" ITEM.
04500 JC=JD
04600 DO 367 KA=JE,8
04700 X=.990
04800 DO 366 K=JC,4
04900 Z=Z+X
05000 366 X=X*100.0
05100 RN(IS+KA)=Z
05200 JC=1
05300 367 Z=0
05400 L=L+1
05500 C L=CHARACTER COUNTER
05600 GO TO 369
05700 365 DO 362 J=1,19
05800 IF(IA.NE.JALPHA(J))GO TO 362
05900 N=35+J
06000 C FOUND A SPECIAL CHARACTER.
06100 GO TO 39
06200 362 CONTINUE
06300 38 N=10-('A'-INP(L))/536870912
06400 C MAGIC NUMBER TO FIND LETTERS
06500 IF(N.LT.10)N=N+7
06600 39 L=L+1
06700 C BLANK=99(=47)
06800 CALL SPACER(N,IFNT,RX,3.30537)
06900 C NUM↑↑=19.7/5.96 FOR BASIC SPACE PER LETTER.
07000 C GET SPACE FOR THIS LETTER.
07100 X=N
07200 IF(JD.EQ.2)X=X*100.
07300 IF(JD.EQ.4)X=X/100.
07400 IF(JD.EQ.1)X=X*10000.
07500 363 Z=Z+X
07600 364 RN(IS+JE)=Z
07700 369 RN(IS+9)=RX
07800 RN(IS+10)=RZ
07900 C FOR CONTINUATION
08000 RA=RA+RX+5
08100 RX=0
08200 RN(IS)=7+RZ
08300 IS=IS+10+RZ
08400 LL=LL+1
08500 PWDS(ITEM+LL)=IS
08600 C PUT IT IN THE PNTR ARRAY
08700 RZ=1.
08800 IF(IA.EQ.KSLA)RZ=0
08900 IF(L.LE.KN)GO TO 368
09000
09100 INP(1)=0
09200 C SO IT WON'T FIND A COMMAND IN THE MAIN PROG.
09300 IF(RJF.NE.0)CALL SETLET
09400 END
09500 C PACKS 4 CHARS/WD, 3 WDS/ITEM. ORDER=[, - . = ( )] 000000.00
09600
09700 SUBROUTINE TYPE
09800 COMMON/ALF/INP(72),ML
09900 TYPE 8005
10000 ACCEPT 2114,INP
10100 2114 FORMAT(72A1)
10200 8005 FORMAT(' TYPE --'/)
10300 END
10600 SUBROUTINE SETLET
10800 COMMON/SCM/V(78),Y,LCNT,STAFF,JLIST(200),REND
10900 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(14),M,K,J,X,A,B
11000 1 /FLM/RPOS(2,300) /PTR/PWDS(250),ITEM,L,I,IX /XRN/RN(4000)
11100 COMMON/FRMT/F78F(1),FA1(1),FA5(1),ASK
11200 EQUIVALENCE (JF,JQ(4)),(ISET,RJQ(12))
11250 DATA DISP/1.4/
11300 M=1
11400 RPOS(1,1)=0
11500 DO 1 K=1,ITEM
11600 IF(FINDIT(K))GO TO 1
11700 C SKIPS NON-NOTES AND WRONG STAFF
11800 M=M+1
11900 RPOS(1,M)=RN(L+2)
12100 1 CONTINUE
12200 CALL SETNUM
12300 CALL SORT2(RPOS,M)
12400 K=2
12500 22 IF(RPOS(1,K).NE.RPOS(1,K-1))GO TO 2
12600 M=M-1
12700 DO 20 J=K,M
12800 20 RPOS(1,J)=RPOS(1,J+1)
12900 C DELETES DOUBLE-STOPS - DOESN'T PUT NUM OVER 1ST NOTE.
13000 GO TO 22
13100 2 K=K+1
13200 IF(K.LT.M)GO TO 22
13300 DO 4 K=2,M
13400 JB=RHORZ(RPOS(1,K))
13500 CALL NOTWRT
13600 JF=JF+1
13700 4 IF(JF.EQ.10)JF=0
13800 CALL DPYOUT(3)
13900 CALL SETPOG(1)
14000 RPOS(1,M+1)=200
14100 J=1
14200 CALL TYPE
14300 REREAD F78F,V
14400 X=V(J)+1
14500 CC M=1
14600 3 K=X
14700 A=RPOS(1,K)
14800 B=RPOS(1,K+1)
14900 RN(ISET+2)=A+(B-A)*(X-K)+DISP
14950 C DISP IS DISPLACEMENT OF CURRENT LETTERS.
15000 IF(RN(ISET+4).NE.0)GO TO 5
15100 RN(ISET+4)=V(J+1)
15200 J=J+2
15300 GO TO 6
15400 C IF P4≠0 TYPE ONLY 1 # FOR EACH ITEM. ALL ITEMS WILL BE AT VRT PS OF P4
15500 C TYPE Nn, Vert pos/Nn, Vert pos/ OR Nn/Nn/ (if P4≠0)
15600 5 J=J+1
15700 6 ISET=ISET+RN(ISET)+3
15800 X=V(J)+1
15900 IF(X.GT.1)GO TO 3
16000 C CAN'T PUT LETTER AT POS. 0 *********
16100 END
16200
16300 SUBROUTINE SETNUM
16400 DIMENSION SU(320)
16500 COMMON RJB,JA,CENTR,JB,RJQ(20),JQ(20)
16600 COMMON/POSI/STF(8),JJB,POS/DPY/ST(4000),WDS(250),MEDIT,IGO
16700 EQUIVALENCE (JC,JQ(1)),(JF,JQ(4)),(RJE,RJQ(3)),(RJD,RJQ(2))
16800 1,(SU(1),ST(3600))
16900 CALL DPYSET(3,SU,320)
17000 CALL DPYBRT(6)
17100 JF=1
17400 POS=STF(JC+4)
17500 RJD=18.
17600 JA=5
17700 RJE=1
17800 END
17900